home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / expr.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  57KB  |  1,905 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "segment.h"
  15. #include "gvars.h"
  16. #include "attr.h"
  17. #include "ops.h"
  18. #include "type.h"
  19. #include "namp.h"
  20. #include "segmentp.h"
  21. #include "genp.h"
  22. #include "miscp.h"
  23. #include "maincasp.h"
  24. #include "setp.h"
  25. #include "typep.h"
  26. #include "gutilp.h"
  27. #include "arithp.h"
  28. #include "gmiscp.h"
  29. #include "smiscp.h"
  30. #include "chapp.h"
  31. #include "axqrp.h"
  32. #include "exprp.h"
  33.  
  34. static int rat_convert(Const, int *);
  35. void gen_attribute(Node);
  36. static int float_mantissa(int);
  37. static void gen_type_attr(Symbol, int);
  38. static int code_map(Symbol);
  39.  
  40. static int code_map_defined; /* set to FALSE if SETL version yields OM */
  41.  
  42. void gen_value(Node node)                                        /*;gen_value*/
  43. {
  44.     /*
  45.      *  This procedure generates code for the v_expressions
  46.      *  or, in other words, the right-hand-sides.
  47.      *
  48.      *  - node is the tree expression for which code is to be generated.
  49.      */
  50.  
  51.     int    save_tasks_declared, can_convert, rat_int;
  52.     Node    pre_node, rec_type_node, id_node, static_node, init_node, obj_node,
  53.       exception_node, expr_node, init_call_node, task_node, entry_node,
  54.       index_node, value_node, arr_l_bd, arr_h_bd, val_l_bd, val_h_bd;
  55.     Symbol    type_name, node_name, rec_type_name, proc_name, return_type,
  56.       obj_name, obj_type, model_name, exception_name, from_type, to_type,
  57.       accessed_type, discr_name;
  58.     Fortup    ft1;
  59.     Symbol    junk_var, comp_name, indx_type, value_type, indx_value_type;
  60.     Tuple    stmts_list;
  61.     Node    list_node, stmt_node, lhs, comp_node, type_node;
  62.     Tuple    d_l, tup, indx_types;
  63.     Const    value;
  64.     int        i, stmts_list_i, size, ivalue;
  65.     long    exprv; /* fixed point value */
  66.  
  67. #ifdef TRACE
  68.     if (debug_flag) {
  69.         gen_trace_node("GEN_VALUE", node);
  70.     }
  71. #endif
  72.  
  73.     while (N_KIND(node) == as_insert) {
  74.         FORTUP(pre_node = (Node), N_LIST(node), ft1);
  75.             compile(pre_node);
  76.         ENDFORTUP(ft1);
  77.         node = N_AST1(node);
  78.     }
  79.  
  80.     type_name = get_type(node);
  81.  
  82.     if (N_KIND(node) == as_null)
  83.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, symbol_null);
  84.     else if (is_simple_name(node)) {
  85.         node_name = N_UNQ(node);
  86.  
  87.         if (is_renaming(node_name)) {
  88.             gen_ks(I_PUSH, mu_addr, node_name);
  89.             if (is_array_type(type_name)) {
  90.                 /* Note: can't be a renaming of a formal parm (transformed */
  91.                 /*       to normal variable). */
  92.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  93.             }
  94.             optional_deref(type_name);
  95.         }
  96.         else if (is_simple_type(type_name)) {
  97.             gen_ks(I_PUSH, kind_of(type_name), node_name);
  98.         }
  99.         else {
  100.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, node_name);
  101.  
  102.             /* Arrays are treated in a different manner, depending on their */
  103.             /* nature: parameters, constants, variables... */
  104.             if (is_array_type(type_name)) {
  105.                 if (is_formal_parameter(node_name)) {
  106.                     /* For a parm, the type template follows the parameter */
  107.                     /* in the stack */
  108.                     gen_s(I_PUSH_EFFECTIVE_ADDRESS,
  109.                       assoc_symbol_get(node_name, FORMAL_TEMPLATE));
  110.                 }
  111.                 else {
  112.                     /* otherwise, the type template address is pushed on the */
  113.                     /* stack */
  114.                     gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  115.                 }
  116.             }
  117.         }
  118.     }
  119.     else {
  120.  
  121.         switch (N_KIND(node) ) {
  122.  
  123.         case(as_create_task):
  124.             gen_s(I_CREATE_TASK, type_name);
  125.             break;
  126.  
  127.         case(as_discard):
  128.             expr_node = N_AST1(node);
  129.             junk_var    = new_unique_name("junk");  /* TBSL: Reusing same var */
  130.             next_local_reference(junk_var);
  131.             gen_ks(I_DECLARE, kind_of(N_TYPE(node)), junk_var);
  132.  
  133.             gen_value(expr_node);
  134.             gen_ksc(I_POP, kind_of(N_TYPE(node)), junk_var,
  135.               "Used only for check");
  136.             break;
  137.  
  138.         case(as_ivalue): 
  139.         case(as_real_literal): 
  140.         case(as_int_literal):
  141.             if (is_fixed_type(type_name)) {
  142.                 exprv = rat_tof(get_ivalue(node),
  143.                   small_of(base_type(type_name)), size_of(type_name));
  144.  
  145.                 /* the evaluation may have raised the overflow flag. Therefore,
  146.                  * constraint_error has to be raised at execution time
  147.                  */
  148.                 if ( ! arith_overflow) {
  149.                     gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name),
  150.                       fixed_const(exprv));
  151.                 }
  152.                 else {
  153.                     gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  154.                     gen(I_RAISE); 
  155.                 }
  156.             }
  157.             else if (is_simple_type(type_name)) {
  158.                 value = get_ivalue(node);
  159.                 if (is_float_type(type_name)) {
  160.                     /* gen_(I_PUSH_IMMEDIATE, kind_of(type_name), value,
  161.                      * ' = '+str(I_TO_F(value)));
  162.                      */
  163.                     if (is_const_rat(value)) { /* try to cnvrt rtnl to real*/
  164.                         chaos("expr.c: rational seen when real expected");
  165.                     }
  166.                     gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), value);
  167.                 }
  168.                 else {
  169.                     if (is_const_rat(value)) { /* try to cnvrt rtnl to int */
  170.                         rat_int = rat_convert(value, &can_convert);
  171.                         if (can_convert) {
  172.                             gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name),
  173.                               int_const(rat_int));
  174.                         }
  175.                         else {
  176.                             gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), value);
  177.                         }
  178.                     }
  179.                     else if (is_const_uint(value)) {
  180.                         /* try to convert universal integer to integer */
  181.                         ivalue = int_toi(UINTV(value));
  182.                         if (!arith_overflow) {/* if can convert to integer */
  183.                             gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name),
  184.                               int_const(ivalue));
  185.                         }
  186.                         else { /* just try again as universal integer */
  187.                             gen_s(I_LOAD_EXCEPTION_REGISTER,
  188.                               symbol_constraint_error);
  189.                             gen(I_RAISE);
  190.                             /* the exceptn has to be raised (overflow on int)
  191.                              * gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name),
  192.                              *    value);
  193.                              */
  194.                         }
  195.                     }
  196.                     else {
  197.                         gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), value);
  198.                     }
  199.                 }
  200.             }
  201.             else 
  202.                 compiler_error("structured ivalue");
  203.             break;
  204.  
  205.         case(as_string_ivalue):
  206.             /*  This created a segment containing the string literal... */
  207.             /* TBSL: note that array_ivalue returns a Segment */
  208.             obj_name  = get_constant_name(array_ivalue(node));
  209.             type_name = N_TYPE(node);
  210.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_name);
  211.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  212.             break;
  213.  
  214.         case(as_index):
  215.             gen_subscript(node);
  216.             optional_deref(type_name);
  217.             break;
  218.  
  219.         case(as_selector):
  220.             gen_address(node);
  221.             optional_deref(type_name);
  222.             break;
  223.  
  224.         case(as_discr_ref):
  225.             discr_name      = N_UNQ(node);
  226.             rec_type_node = N_AST1(node);
  227.             rec_type_name   = N_UNQ(rec_type_node);
  228.             gen_sc(I_PUSH_EFFECTIVE_ADDRESS, rec_type_name,
  229.               "fetch discriminant from template");
  230.             /* SETL version has discr_name as last argument, this is presumably
  231.              * comment part of instruction. For now ignore this
  232.              * gen_ki(I_ADD_IMMEDIATE, mu_word,
  233.              *   TT_C_RECORD_DISCR + FIELD_OFFSET(discr_name)(TARGET),
  234.              *   discr_name);
  235.              */
  236.             /* TBSL: review trnsltn of next line VERY carefully  ds 10-2-85 */
  237.             if (TYPE_KIND(rec_type_name) == TT_D_RECORD) {
  238.                 gen_ki(I_ADD_IMMEDIATE, mu_word,
  239.                   ((sizeof(struct tt_d_type)/sizeof(int)) + 
  240.                   1 + 2 * FIELD_OFFSET(discr_name)));
  241.             }
  242.             else {
  243.                 gen_ki(I_ADD_IMMEDIATE, mu_word,
  244.                   ((sizeof(struct tt_d_type)/sizeof(int))
  245.                   + FIELD_OFFSET(discr_name)));
  246.             }
  247.             gen_k(I_DEREF, kind_of(type_name));
  248.             break;
  249.  
  250.         case(as_all):
  251.             gen_address(node);
  252.             if (is_simple_type(type_name)) {
  253.                 gen_k(I_DEREF, kind_of(type_name));
  254.             }
  255.             else {
  256.                 Symbol not_null;
  257.                 /* test for null explicitly, because optional_deref is a noop
  258.                  * on an array  or record (which are always  references).
  259.                  */
  260.                 gen_k(I_DUPLICATE, mu_addr);
  261.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, symbol_null);
  262.                 gen_k(I_COMPARE, mu_addr);
  263.                 not_null = new_unique_name("ok_access");
  264.                 gen_s(I_JUMP_IF_FALSE, not_null);
  265.                 gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  266.                 gen(I_RAISE);
  267.                 gen_s(I_LABEL, not_null);
  268.             }
  269.             break;
  270.  
  271.         case(as_call):
  272.             id_node   = N_AST1(node);
  273.             proc_name   = N_UNQ(id_node);
  274.             return_type = TYPE_OF(proc_name);
  275.             gen_kc(I_DUPLICATE, kind_of(return_type), "place holder");
  276.             compile(node);       /* processed from now as a procedure call */
  277.             break;
  278.  
  279.         case(as_slice):
  280.             gen_address(node);
  281.             break;
  282.  
  283.         case(as_raise):
  284.             compile(node);
  285.             break;
  286.  
  287.         case(as_attribute): 
  288.         case(as_range_attribute):
  289.             gen_attribute(node);
  290.             break;
  291.  
  292.         case(as_record_aggregate): 
  293.         case(as_record_ivalue):
  294.             static_node = N_AST1(N_AST1(node));
  295.             init_node = N_AST2(N_AST1(node));
  296.             obj_node = N_AST2(node);
  297.             obj_name = N_UNQ(obj_node);
  298.             obj_type = get_type(obj_node);
  299.  
  300.             if (!has_static_size(obj_type)) {
  301.                 next_local_reference(obj_name);
  302.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_type);
  303.                 gen(I_CREATE_STRUC);
  304.                 gen_s(I_UPDATE_AND_DISCARD, obj_name);
  305.                 /* Warning: Discriminants may be static or not, but must be */
  306.                 /*          evaluated before other components */
  307.                 if (static_node != OPT_NODE) {
  308.                     stmts_list = tup_copy(N_LIST(static_node));
  309.                     if (init_node != OPT_NODE) {
  310.                         /* init_node is an as_statements */
  311.                         list_node = N_AST1(init_node);
  312.                         d_l       = discriminant_list_get(obj_type);
  313.                         FORTUP(stmt_node = (Node), N_LIST(list_node), ft1);
  314.                             if (N_KIND(stmt_node) == as_assignment)  {
  315.                                 /* lhs is as_selector */
  316.                                 lhs = N_AST1(stmt_node);
  317.                                 comp_node = N_AST2(lhs);
  318.                                 comp_name = N_UNQ(comp_node);
  319.                                 if (tup_mem((char *) comp_name, d_l)) {
  320.                                     /* This is a discriminant */
  321.                                     stmts_list = tup_exp(stmts_list,
  322.                                       tup_size(stmts_list)+1);
  323.                                     for (stmts_list_i = tup_size(stmts_list);
  324.                                       stmts_list_i > 1; stmts_list_i--) {
  325.                                         stmts_list[stmts_list_i] =
  326.                                           stmts_list[stmts_list_i-1];
  327.                                     }
  328.                                     stmts_list[1] = (char *)stmt_node;
  329.                                 }
  330.                                 else {
  331.                                     stmts_list =
  332.                                       tup_with(stmts_list, (char *) stmt_node);
  333.                                 }
  334.                             }
  335.                             else if (N_KIND(stmt_node) == as_init_call) {
  336.                                 tup  = N_LIST(N_AST2(stmt_node));
  337.                                 size = tup_size(tup);
  338.                                 /* lhs is as_selector */
  339.                                 lhs  = (Node) tup[size];
  340.                                 comp_node = N_AST2(lhs);
  341.                                 comp_name = N_UNQ(comp_node);
  342.                                 if (tup_mem((char *) comp_name, d_l)) {
  343.                                     /* This is a discriminant */
  344.                                     stmts_list = tup_exp(stmts_list,
  345.                                       tup_size(stmts_list)+1);
  346.                                     for (stmts_list_i = tup_size(stmts_list);
  347.                                       stmts_list_i > 1; stmts_list_i--) {
  348.                                         stmts_list[stmts_list_i] =
  349.                                           stmts_list[stmts_list_i-1];
  350.                                     }
  351.                                     stmts_list[1] = (char *)stmt_node;
  352.                                 }
  353.                                 else {
  354.                                     stmts_list =
  355.                                       tup_with(stmts_list, (char *) stmt_node);
  356.                                 }
  357.                             }
  358.                             else {
  359.                                 stmts_list = tup_with(stmts_list,
  360.                                   (char *) stmt_node);
  361.                             }
  362.                         ENDFORTUP(ft1);
  363.                     }
  364.  
  365.                     FORTUP(comp_node = (Node), stmts_list, ft1)
  366.                         compile(comp_node);
  367.                     ENDFORTUP(ft1);
  368.                     init_node = OPT_NODE;    /* all done. */
  369.                 }
  370.             }
  371.             else if (is_ivalue(node)) {
  372.                 assign_same_reference(obj_name,
  373.                   get_constant_name(record_ivalue(node)) );
  374.             }
  375.             else if (CURRENT_LEVEL == 1) {
  376.                 next_global_reference_template(obj_name, record_ivalue(node));
  377.             }
  378.             else if (tup_size(N_LIST(static_node)) == 0) {
  379.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_type);
  380.                 gen(I_CREATE_STRUC);
  381.                 next_local_reference(obj_name);
  382.                 gen_s(I_UPDATE_AND_DISCARD, obj_name);
  383.             }
  384.             else {
  385.                 model_name = get_constant_name(record_ivalue(node));
  386.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, model_name);
  387.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_type);
  388.                 gen(I_CREATE_COPY_STRUC);
  389.                 next_local_reference(obj_name);
  390.                 gen_s(I_UPDATE_AND_DISCARD, obj_name);
  391.             }
  392.  
  393.             compile(init_node);
  394.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_name);
  395.             break;
  396.  
  397.         case(as_array_aggregate): 
  398.         case(as_array_ivalue):
  399.             static_node = N_AST1(N_AST1(node));
  400.             init_node = N_AST2(N_AST1(node));
  401.             obj_node = N_AST2(node);
  402.             obj_name = N_UNQ(obj_node);
  403.             obj_type = get_type(obj_node);
  404.  
  405.             /*  Check and see if can create a segment containing the aggregate
  406.              *  value...
  407.              */
  408.  
  409.             if (!has_static_size(obj_type)) {
  410.  
  411.                 /*  CASE 1.  We  cannot create a segment because have anon.
  412.                  *   types decl which are used for type checking at run time
  413.                  */
  414.  
  415.                 next_local_reference(obj_name);
  416.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_type);
  417.                 gen(I_CREATE_STRUC);
  418.                 if (is_array_type(obj_type)) {
  419.                     gen_ks(I_DISCARD_ADDR, 1, obj_type);
  420.                 }
  421.                 gen_s(I_UPDATE_AND_DISCARD, obj_name);
  422.                 FORTUP(comp_node = (Node), N_LIST(static_node), ft1);
  423.                     compile(comp_node);
  424.                 ENDFORTUP(ft1);
  425.             }
  426.             else if (is_ivalue(node)) {
  427.                 /* TBSL: note that array_ivalue returns a Segment */
  428.                 /*  CASE 2.  The aggregate is static and some (or all) values
  429.                  * can be put into a segment for that aggregate.
  430.                  */
  431.  
  432.                 assign_same_reference(obj_name,
  433.                   get_constant_name(array_ivalue(node)));
  434.             }
  435.             else if (CURRENT_LEVEL == 1) {
  436.                 /*  CASE 3.    */
  437.                 next_global_reference_template(obj_name, array_ivalue(node));
  438.             }
  439.             else if (tup_size(N_LIST(static_node)) == 0) {
  440.                 /*  CASE 4.  There are no static values for the aggregate.
  441.                  *  Hence, all values are assigned with run-time assignment
  442.                  *  statements...
  443.                  */
  444.  
  445.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_type);
  446.                 gen(I_CREATE_STRUC);
  447.                 next_local_reference(obj_name);
  448.                 gen_ks(I_DISCARD_ADDR, 1 , obj_type);
  449.                 gen_s(I_UPDATE_AND_DISCARD, obj_name);
  450.             }
  451.             else {
  452.                 /*  CASE 5.  There are both static values and non-static values
  453.                  *  for the aggregate.  A segment is created with the static
  454.                  *  values, and non-static values are assigned with run-time
  455.                  *  assignment statements...
  456.                  */
  457.                 model_name = get_constant_name(array_ivalue(node));
  458.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, model_name);
  459.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_type);
  460.                 gen(I_CREATE_COPY_STRUC);
  461.                 next_local_reference(obj_name);
  462.                 gen_ks(I_DISCARD_ADDR, 1, obj_type);
  463.                 gen_s(I_UPDATE_AND_DISCARD, obj_name);
  464.             }
  465.  
  466.             /* Proces the non-static value and push addresses of the obj_name
  467.              * and obj_type
  468.              */
  469.             compile(init_node);
  470.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_name);
  471.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, obj_type);
  472.             break;
  473.  
  474.         case(as_type_and_value):
  475.             /* Special node: generate a record value and elaborate a record */
  476.             /* subtype, constrained by the value's discriminants */
  477.             type_node = N_AST1(node);
  478.             expr_node = N_AST2(node);
  479.             type_name = N_UNQ(type_node);
  480.  
  481.             gen_value(expr_node);
  482.             gen_subtype(type_name);
  483.             break;
  484.  
  485.         case(as_test_exception):
  486.             exception_node = N_AST1(node);
  487.             exception_name   = N_UNQ(exception_node);
  488.             gen_s(I_TEST_EXCEPTION_REGISTER, exception_name);
  489.             break;
  490.  
  491.         case(as_convert):
  492.             expr_node = N_AST2(node);
  493.             from_type = base_type(get_type(expr_node));
  494.             to_type   = N_TYPE(node);
  495.             gen_value(expr_node);
  496.             gen_convert(from_type, to_type);
  497.             break;
  498.  
  499.         case(as_qual_discr):
  500.             type_name    = N_TYPE(node);
  501.             value_node = N_AST1(node);
  502.             gen_value(value_node);
  503.             /* A qual_discr on a TT_D_RECORD is meaningless.
  504.              * Special code may be emitted TBSL.
  505.              */
  506.             if (type_name != get_type(value_node)
  507.               && TYPE_KIND(type_name) != TT_D_RECORD
  508.               && SIGNATURE(type_name) != SIGNATURE(root_type(type_name))) {
  509.                 gen_s(I_QUAL_DISCR, type_name);
  510.             }
  511.             break;
  512.  
  513.         case(as_qual_range):
  514.             type_name  = N_TYPE(node);
  515.             value_node = N_AST1(node);
  516.             gen_value(value_node);
  517.             gen_s(I_QUAL_RANGE, type_name);
  518.             break;
  519.  
  520.         case(as_qual_index):
  521.             type_name    = N_TYPE(node);
  522.             value_node = N_AST1(node);
  523.             gen_value(value_node);
  524.             value_type = get_type(value_node);
  525.             if (value_type != type_name && TYPE_KIND(type_name) != TT_D_ARRAY) {
  526.                 gen_s(I_QUAL_INDEX, type_name);
  527.             }
  528.             /* the bounds of the value and the array itself must be equal. */
  529.             else if (value_type != type_name)  {   /* case of TT_D_ARRAY. */
  530.                 indx_types = (Tuple)SIGNATURE(type_name)[1];
  531.                 for (i = 1; i <= tup_size(indx_types); i++)  {
  532.                     indx_type = (Symbol)indx_types[i];
  533.                     arr_l_bd = (Node)SIGNATURE(indx_type)[2];
  534.                     arr_h_bd = (Node)SIGNATURE(indx_type)[3];
  535.                     indx_value_type =
  536.                       (Symbol)((Tuple)SIGNATURE(value_type)[1])[i];
  537.                     val_l_bd = (Node)SIGNATURE(indx_value_type)[2];
  538.                     val_h_bd = (Node)SIGNATURE(indx_value_type)[3];
  539.                     if (is_ivalue(arr_l_bd) && is_ivalue(val_l_bd) &&
  540.                       INTV(get_ivalue(arr_l_bd)) != INTV(get_ivalue(val_l_bd))){
  541.                         gen_s(I_LOAD_EXCEPTION_REGISTER,
  542.                           symbol_constraint_error);
  543.                         gen(I_RAISE);
  544.                         break;
  545.                     }
  546.                     if (is_ivalue(arr_h_bd) && is_ivalue(val_h_bd) &&
  547.                       INTV(get_ivalue(arr_h_bd)) != INTV(get_ivalue(val_h_bd))){
  548.                         gen_s(I_LOAD_EXCEPTION_REGISTER,
  549.                           symbol_constraint_error);
  550.                         gen(I_RAISE);
  551.                         break;
  552.                     }
  553.                 }
  554.             }
  555.             break;
  556.  
  557.         case(as_qual_sub):
  558.             type_name  = N_TYPE(node);
  559.             value_node = N_AST1(node);
  560.             gen_value(value_node);
  561.             gen_s(I_QUAL_SUB, type_name);
  562.             break;
  563.  
  564.         case(as_qual_adiscr):
  565.             type_name  = (Symbol)designated_type(N_TYPE(node));
  566.             value_node = N_AST1(node);
  567.             gen_value(value_node);
  568.             gen_access_qual(as_qual_discr, type_name);
  569.             break;
  570.  
  571.         case(as_qual_aindex):
  572.             type_name  = (Symbol)designated_type(N_TYPE(node));
  573.             value_node = N_AST1(node);
  574.             gen_value(value_node);
  575.             gen_access_qual(as_qual_index, type_name);
  576.             break;
  577.  
  578.         case(as_new):
  579.             type_node = N_AST1(node);
  580.             expr_node = N_AST2(node);
  581.             type_name = N_TYPE(node);
  582.             accessed_type = N_UNQ(type_node);
  583.             if (N_KIND(expr_node) == as_init_call) {
  584.                 init_call_node = expr_node;
  585.                 expr_node      = OPT_NODE;
  586.             }
  587.             else {
  588.                 init_call_node = OPT_NODE;
  589.             }
  590.  
  591.             if (CONTAINS_TASK(accessed_type)) {
  592.                 save_tasks_declared = TASKS_DECLARED;
  593.                 TASKS_DECLARED      = FALSE;
  594.                 /* Note, make want to have global corresponding to this const */
  595.                 gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const_null_task);
  596.                 gen_c(I_LINK_TASKS_DECLARED, "new task frame for allocator");
  597.             }
  598.  
  599.             if (expr_node != OPT_NODE) {
  600.                 gen_value(expr_node);
  601.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  602.                 gen_s(I_ALLOCATE_COPY, accessed_type);
  603.             }
  604.             else {
  605.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, accessed_type);
  606.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  607.                 gen(I_ALLOCATE);
  608.                 if (init_call_node != OPT_NODE) {
  609.                     if (is_array_type(accessed_type)) {
  610.                         gen_k(I_DUPLICATE, mu_addr);
  611.                         gen_k(I_DEREF, mu_dble);
  612.                     }
  613.                     compile(init_call_node);
  614.                     if (is_array_type(accessed_type)) {
  615.                         gen_ks(I_DISCARD_ADDR, 2, (Symbol) 0);
  616.                     }
  617.                 }
  618.             }
  619.  
  620.             if (CONTAINS_TASK(accessed_type)) {
  621.                 gen_s(I_ACTIVATE_NEW, type_name);
  622.                 TASKS_DECLARED = save_tasks_declared;
  623.             }
  624.             break;
  625.  
  626.         case(as_entry_name):
  627.             task_node = N_AST1(node);
  628.             entry_node = N_AST2(node);
  629.             index_node = N_AST3(node);
  630.             if (task_node != OPT_NODE)
  631.                 gen_value(task_node);
  632.  
  633.             if (index_node == OPT_NODE) {
  634.                 reference_of(N_UNQ(entry_node));
  635.                 gen_kv(I_PUSH_IMMEDIATE, mu_byte,
  636.                   int_const((int)REFERENCE_OFFSET));
  637.                 gen_kvc(I_PUSH_IMMEDIATE, mu_word, int_const_0, "simple entry");
  638.             }
  639.             else {
  640.                 reference_of(N_UNQ(entry_node));
  641.                 gen_kvc(I_PUSH_IMMEDIATE, mu_byte,
  642.                   int_const((int) REFERENCE_OFFSET), "family");
  643.                 gen_value(index_node);
  644.             }
  645.             break;
  646.  
  647.         case(as_current_task):
  648.             gen(I_CURRENT_TASK);
  649.             break;
  650.  
  651.             /* Unary operators */
  652.         case(as_un_op):
  653.             gen_unary(node);
  654.             break;
  655.  
  656.             /* Binary operators */
  657.         case(as_op):
  658.             gen_binary(node);
  659.             break;
  660.  
  661.         case(as_deleted):
  662.             ;
  663.  
  664.         default:
  665.             compiler_error("Unknown node at GEN_VALUE");
  666.         }
  667.     }
  668. }
  669.  
  670. static int rat_convert(Const con, int *can_convert)            /*;rat_convert*/
  671. {
  672.     int rat_int;
  673.  
  674.     rat_int = rat_toi(RATV(con));
  675.     *can_convert = !arith_overflow;
  676.     return rat_int;
  677. }
  678.  
  679. void gen_unary(Node node)                                /*;gen_unary*/
  680. {
  681.     /* Unary operators */
  682.     Node    op_node, args_node, op1;
  683.     Symbol    opcode, type_name;
  684.  
  685. #ifdef TRACE
  686.     if (debug_flag)
  687.         gen_trace_node("GEN_UNARY", node);
  688. #endif
  689.  
  690.     op_node = N_AST1(node);
  691.     args_node = N_AST2(node);
  692.     opcode    = N_UNQ(op_node);
  693.     type_name = N_TYPE(node);
  694.     op1 = (Node) N_LIST(args_node)[1];
  695.  
  696.     gen_value(op1);
  697.     if (opcode == symbol_addui || opcode == symbol_addufl
  698.       || opcode == symbol_addufx)
  699.         ;
  700.     else if (opcode == symbol_subufx || opcode == symbol_subui)
  701.         gen_k(I_NEG, kind_of(type_name));
  702.     else if (opcode == symbol_subufl)
  703.         gen_k(I_FLOAT_NEG, kind_of(type_name));
  704.     else if (opcode == symbol_absi || opcode == symbol_absfx)
  705.         gen_k(I_ABS, kind_of(type_name));
  706.     else if (opcode == symbol_absfl)
  707.         gen_k(I_FLOAT_ABS, kind_of(type_name));
  708.     else if (opcode == symbol_not) {
  709.         if (is_array_type(type_name))
  710.             gen(I_ARRAY_NOT);
  711.         else
  712.             gen(I_NOT);
  713.     }
  714.     else
  715.         compiler_error("Unexpected unary operator");
  716. }
  717.  
  718. void gen_binary(Node node)                                        /*;gen_binary*/
  719. {
  720.     /* The SETL constant code_map is realized in the C version by a procedure
  721.      * code_map().
  722.      */
  723.  
  724.     Node    op_node, args_node, op1, op2;
  725.     Symbol    opcode, type_name, andthen, orelse, op1_type, op2_type;
  726.     int        op_instr, aopcode;
  727. #ifdef TRACE
  728.     if (debug_flag)
  729.         gen_trace_node("GEN_BINARY", node);
  730. #endif
  731.  
  732.     op_node = N_AST1(node);
  733.     args_node = N_AST2(node);
  734.     opcode = N_UNQ(op_node);
  735.     type_name = N_TYPE(node);
  736.     op1 = (Node) N_LIST(args_node)[1];
  737.     op2 = (Node) N_LIST(args_node)[2];
  738.  
  739.     if (opcode == symbol_and|| opcode == symbol_or || opcode == symbol_xor) {
  740.         gen_value(op1);
  741.         gen_value(op2);
  742.         if (is_array_type(type_name)) {
  743.             if (opcode == symbol_and) aopcode = I_ARRAY_AND;
  744.             else if (opcode == symbol_or) aopcode = I_ARRAY_OR;
  745.             else if (opcode == symbol_xor) aopcode = I_ARRAY_XOR;
  746.             gen(aopcode);
  747.         }
  748.         else {
  749.             gen(code_map(opcode));
  750.         }
  751.     }
  752.     else if (opcode == symbol_andthen) {
  753.         gen_value(op1);
  754.         gen_k(I_DUPLICATE, mu_byte);
  755.         andthen = new_unique_name("andthen");
  756.         gen_s(I_JUMP_IF_FALSE, andthen);
  757.         gen_value(op2);
  758.         gen(I_AND);
  759.         gen_s(I_LABEL, andthen);
  760.     }
  761.     else if(opcode == symbol_orelse) {
  762.         gen_value(op1);
  763.         gen_k(I_DUPLICATE, mu_byte);
  764.         orelse = new_unique_name("orelse");
  765.         gen_s(I_JUMP_IF_TRUE, orelse);
  766.         gen_value(op2);
  767.         gen(I_OR);
  768.         gen_s(I_LABEL, orelse);
  769.     }
  770.     else if (opcode == symbol_in || opcode == symbol_notin) {
  771.         op2_type = N_UNQ(op2);
  772.         if (is_record_type(op2_type) && !has_discriminant(op2_type)) {
  773.             gen_ki(I_PUSH_IMMEDIATE, mu_byte, opcode == symbol_in);
  774.         }
  775.         else {
  776.             if (is_access_type(op2_type)) {
  777.                 /* if the acces value is null, it belongs to the subtype.
  778.                  * Otherwise, it is the designated object that must belong
  779.                  * to the designated subtype.
  780.                  */
  781.                 Symbol desig_type, end_if, deref;
  782.  
  783.                 end_if = new_unique_name("end_if");
  784.                 deref  = new_unique_name("deref");
  785.                 desig_type = designated_type(op2_type);
  786.  
  787.                 gen_value(op1);
  788.                 gen_k(I_DUPLICATE, kind_of(op2_type));
  789.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, symbol_null);
  790.                 gen_k(I_COMPARE, mu_addr);
  791.                 gen_s(I_JUMP_IF_FALSE, deref);
  792.                 gen_ks(I_DISCARD_ADDR, 1, (Symbol)0);
  793.                 gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_boolean),
  794.                   int_const(TRUE));
  795.                 gen_s(I_JUMP, end_if);
  796.  
  797.                 gen_s(I_LABEL, deref);
  798.                 if (is_simple_type(desig_type) || is_array_type(desig_type))
  799.                     gen_k(I_DEREF, kind_of(desig_type));
  800.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, desig_type);   /* Type name */
  801.                 gen(I_MEMBERSHIP);
  802.                 gen_s(I_LABEL, end_if);
  803.             }
  804.             else {
  805.                 gen_value(op1);
  806.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, op2_type);   /* Type name */
  807.                 gen(I_MEMBERSHIP);
  808.             }
  809.             if (opcode == symbol_notin)
  810.                 gen(I_NOT);
  811.         }
  812.     }
  813.     else if (opcode == symbol_eq || opcode == symbol_ne || opcode == symbol_lt
  814.       || opcode == symbol_gt || opcode == symbol_le ||opcode == symbol_ge){
  815.  
  816.         gen_value(op1);
  817.         gen_value(op2);
  818.  
  819.         op1_type = get_type(op1);
  820.         if (is_simple_type(op1_type)) {
  821.             if (is_float_type(op1_type))
  822.                 gen_k(I_FLOAT_COMPARE, kind_of(op1_type));
  823.             else
  824.                 gen_k(I_COMPARE, kind_of(op1_type));
  825.         }
  826.         else if (is_array_type(op1_type)) {
  827.             if (opcode == symbol_eq || opcode == symbol_ne)
  828.                 gen(I_COMPARE_STRUC);
  829.             else
  830.                 gen(I_COMPARE_ARRAYS);
  831.         }
  832.         else if (is_record_type(op1_type)) {
  833.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, op1_type);
  834.             gen(I_COMPARE_STRUC);
  835.         }
  836.  
  837.         /* Note: the compare operation push a byte on the stack whose two */
  838.         /*       least significant bits mean 'is_equal' and 'is_greater' */
  839.  
  840.         if(opcode == symbol_ne) {
  841.             gen(I_IS_EQUAL);
  842.             gen(I_NOT);
  843.         }
  844.         else {
  845.             gen(code_map(opcode));
  846.         }
  847.     }
  848.     else if (opcode == symbol_addi) {
  849.         if (is_ivalue(op1)) {
  850.             gen_value(op2);
  851.             gen_ki(I_ADD_IMMEDIATE, kind_of(type_name), get_ivalue_int(op1));
  852.         }
  853.         else if (is_ivalue(op2)) {
  854.             gen_value(op1);
  855.             gen_ki(I_ADD_IMMEDIATE, kind_of(type_name), get_ivalue_int(op2));
  856.         }
  857.         else {
  858.             gen_value(op1);
  859.             gen_value(op2);
  860.             gen_k(code_map(opcode), kind_of(type_name));
  861.         }
  862.     }
  863.     else if (opcode == symbol_subi) {
  864.         if (is_ivalue(op2)) {
  865.             gen_value(op1);
  866.             gen_ki(I_ADD_IMMEDIATE, kind_of(type_name), -get_ivalue_int(op2));
  867.         }
  868.         else {
  869.             gen_value(op1);
  870.             gen_value(op2);
  871.             gen_k(code_map(opcode), kind_of(type_name));
  872.         }
  873.     }
  874.     else if (opcode == symbol_cat) {
  875.         gen_value(op1);
  876.         gen_value(op2);
  877.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, base_type(type_name));
  878.         gen(I_ARRAY_CATENATE);
  879.     }
  880.     else if (opcode == symbol_mulfx || opcode == symbol_divfx) {
  881.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  882.         gen_value(op1);
  883.         op1_type = get_type(op1);
  884.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, op1_type);
  885.         gen_value(op2);
  886.         op2_type = get_type(op2);
  887.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, op2_type);
  888.         gen(code_map(opcode));
  889.         /* note: a qual_range is done implicitly by the fix_xxx instruction */
  890.     }
  891.     else if (opcode == symbol_mulfxi || opcode == symbol_divfxi) {
  892.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  893.         gen_value(op1);
  894.         op1_type = get_type(op1);
  895.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, op1_type);
  896.         gen_value(op2);
  897.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, symbol_integer);
  898.         gen_s(I_CONVERT_TO, symbol_dfixed);
  899.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, symbol_dfixed);
  900.         gen(code_map(opcode));
  901.     }
  902.     else if (opcode == symbol_mulfix) {
  903.         gen_value(op2);
  904.         op2_type = get_type(op2);
  905.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, op2_type);
  906.         gen_value(op1);
  907.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, symbol_dfixed);
  908.         gen(code_map(opcode));
  909.     }
  910.     else {
  911.         gen_value(op1);
  912.         gen_value(op2);
  913.         op_instr = code_map(opcode);
  914.         if (code_map_defined) {/*if code_map knows about opcode */
  915.             gen_k(op_instr, kind_of(type_name));
  916.         }
  917.         else
  918.             compiler_error("Unknown operator:");
  919.     }
  920. }
  921.  
  922. void gen_attribute(Node node)                                /*;gen_attribute*/
  923. {
  924.     /*SETL float_mantissa macro is procedure in C following this one.*/
  925.     /* const
  926.      * internal_map is not needed in  C version.
  927.      * internal_map = {['T_FIRST',     a_T_FIRST],
  928.      *   ['T_LAST',       a_T_LAST],
  929.      *   ['T_LENGTH',   a_T_LENGTH],
  930.      *   ['T_RANGE',     a_T_RANGE]};
  931.      */
  932.     Const    old_lbd, old_ubd; 
  933.     Rational rat;
  934.  
  935.     int        *rat_n, *rat_d, *ivalue_i; /* multi-precision integers*/
  936.     Node    lbd_node, ubd_node, delta_node, low, high;
  937.     int        ivalue_n;
  938.     int        fmantissa, digits_int, ivalue_int, i;
  939.     Tuple    tup;
  940.     Const    type_small, root_small;
  941.     int        l, low_int, high_int;
  942.     Const    low_value, high_value, digits, const_1, const_2, rat_const_v;
  943.     double    fvalue;
  944.     Rational    rvalue, rat_t;
  945.     Node    arg1, arg2, comp_node, digs;
  946.     Symbol    from_type, to_type, type_name, comp_name;
  947.     Symbol    junk_var, field;
  948.     Tuple    index_list;
  949.     int        attribute;
  950.     long    low_long, high_long, rvalue_long;    /* fixed point */
  951.     Tuple    repr_tup, align_info, attribute_list;
  952.     Fortup    ft1;
  953.  
  954. #ifdef TRACE
  955.     if (debug_flag)
  956.         gen_trace_node("GEN_ATTRIBUTE", node);
  957. #endif
  958.  
  959.     arg1 = N_AST2(node);
  960.     arg2 = N_AST3(node);
  961.     attribute = (int) attribute_kind(node);
  962.  
  963. #ifdef TRACE
  964.     if (debug_flag)
  965.         gen_trace_string("   ATTRIBUTE:", attribute_str(attribute));
  966. #endif
  967.  
  968.     /*TBSL(JC): in GEN_ATTRIBUTE type of static attributes of real types */
  969.  
  970.     switch (attribute) {
  971.  
  972.     case(ATTR_ADDRESS):
  973.         gen_address(arg1);
  974.         break;
  975.  
  976.     case(ATTR_AFT):     /* Computed by the expander? TBSL */
  977.         type_name = N_UNQ(arg1);
  978.         tup = get_constraint(type_name);
  979.         delta_node = (Node) tup[4];
  980.         rat_const_v  = get_ivalue(delta_node);
  981.         if (rat_const_v->const_kind != CONST_RAT)
  982.             chaos("expr: argument not rational");
  983.         rat = rat_const_v->const_value.const_rat;
  984.         ivalue_1 = int_fri(1); 
  985.         ivalue_i = int_fri(1);
  986.         rat_n = num(rat); 
  987.         rat_d = den(rat);
  988.         rat_n     = int_mul(rat_n, int_fri(10));
  989.         while (int_lss(rat_n , rat_d)) {
  990.             ivalue_i = int_add(ivalue_i, ivalue_1);
  991.             rat_n      = int_mul(rat_n, ivalue_10);
  992.         }
  993.         ivalue_n = int_toi(ivalue_i);
  994.         /* TBSL: may need extra check for long case here, though for now
  995.          * will crash if want long integer value as will get overflow
  996.          */
  997.         if (arith_overflow)
  998.             chaos("expr.c ATTR_AFT overflow during conversion");
  999.         gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer), int_const(ivalue_n));
  1000.         break;
  1001.  
  1002.         /*  ("BASE): */
  1003.  
  1004.     case(ATTR_CALLABLE):
  1005.         gen_value(arg1);
  1006.         gen_kv(I_ATTRIBUTE, ATTR_CALLABLE, int_const(0));
  1007.         break;
  1008.         /*  ("T_CONSTRAINED"): */
  1009.  
  1010.     case(ATTR_O_CONSTRAINED):
  1011.         if (is_record_type(get_type(arg1))) {
  1012.             gen_address(arg1);     /* 1st field in record */
  1013.             gen_kc(I_DEREF, mu_byte, "constrained flag");
  1014.         }
  1015.         else {
  1016.             gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_boolean), int_const(TRUE));
  1017.         }
  1018.         break;
  1019.  
  1020.     case(ATTR_COUNT):
  1021.         gen_value(arg1);
  1022.         gen_kv(I_ATTRIBUTE, ATTR_COUNT, int_const(0));
  1023.         break;
  1024.  
  1025.     case (ATTR_DELTA):
  1026.         to_type    = N_TYPE(node);
  1027.         type_name  = N_UNQ(arg1);
  1028.         tup        = get_constraint(type_name);
  1029.         delta_node = (Node)numeric_constraint_delta(tup);
  1030.         rat_const_v  = get_ivalue(delta_node);
  1031.         /* convert rational value to indicated target type */
  1032.         if (is_fixed_type(to_type)) {
  1033.             rvalue_long = rat_tof(rat_const_v, small_of(base_type(to_type)),
  1034.               size_of(to_type));
  1035.             gen_kv(I_PUSH_IMMEDIATE,kind_of(to_type), fixed_const(rvalue_long));
  1036.         }
  1037.         else {        /* can only be float */
  1038.             fvalue = rat_tor(RATV(rat_const_v), ADA_REAL_DIGITS);
  1039.             gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_float), real_const(fvalue));
  1040.         }
  1041.         break;
  1042.  
  1043.     case(ATTR_DIGITS):   /* Folded by FE unless it appears in a generic */
  1044.         type_name    = N_UNQ(arg1);
  1045.         tup = SIGNATURE(type_name);
  1046.         digs = (Node) tup[4];
  1047.         digits = get_ivalue(digs);
  1048.         gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer), digits);
  1049.         break;
  1050.  
  1051.     case(ATTR_EMAX):     /* Folded by FE unless it appears in a generic */
  1052.         type_name    = N_UNQ(arg1);
  1053.         tup = SIGNATURE(type_name);
  1054.         digs = (Node) tup[4];
  1055.         digits_int= get_ivalue_int(digs);
  1056.         fmantissa    = float_mantissa(digits_int);
  1057.         gen_kv(I_PUSH_IMMEDIATE,kind_of(symbol_integer),int_const(4*fmantissa));
  1058.         break;
  1059.  
  1060.     case(ATTR_EPSILON):   /* Folded by FE unless it appears in a generic */
  1061.         type_name    = N_UNQ(arg1);
  1062.         tup = SIGNATURE(type_name);
  1063.         digs = (Node) tup[4];
  1064.         digits_int       = get_ivalue_int(digs);
  1065.         fmantissa    = float_mantissa(digits_int);
  1066.         fvalue       = pow(2.0, -(double) (fmantissa-1));
  1067.         gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_float), real_const(fvalue));
  1068.         break;
  1069.  
  1070.     case(ATTR_T_FIRST): 
  1071.     case(ATTR_T_LAST):
  1072.     case(ATTR_T_LENGTH): 
  1073.     case(ATTR_T_RANGE):
  1074.         /* Note: cf. GEN_SUBTYPE for some optimizations on 'range */
  1075.         type_name = N_UNQ(arg1);
  1076.         if (is_array_type(type_name)) {
  1077.             tup = SIGNATURE(type_name);
  1078.             index_list = (Tuple) tup[1];
  1079.             type_name = (Symbol) index_list[get_ivalue_int(arg2)];
  1080.         }
  1081.         tup = SIGNATURE(type_name);
  1082.         low = (Node) tup[2];
  1083.         high = (Node) tup[3];
  1084.         low_value  = get_ivalue(low); 
  1085.         high_value = get_ivalue(high);
  1086.  
  1087.         if ((attribute == ATTR_T_RANGE) && (low_value->const_kind != CONST_OM
  1088.           && high_value->const_kind != CONST_OM)) {
  1089.             gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), low_value);
  1090.             gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), high_value);
  1091.             return;
  1092.         }
  1093.         else if((attribute==ATTR_T_FIRST) && low_value->const_kind != CONST_OM){
  1094.             if (is_fixed_type(type_name)) {
  1095.                 low_long= rat_tof(low_value, small_of(base_type(type_name)),
  1096.                   size_of(type_name));
  1097.                 gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name),
  1098.                   fixed_const(low_long));
  1099.             }
  1100.             else {
  1101.                 gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), low_value);
  1102.             }
  1103.             return;
  1104.         }
  1105.         else if((attribute==ATTR_T_LAST) && high_value->const_kind != CONST_OM){
  1106.             if (is_fixed_type(type_name)) {
  1107.                 high_long= rat_tof(high_value, small_of(base_type(type_name)),
  1108.                   size_of(type_name));
  1109.                 gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name),
  1110.                   fixed_const(high_long));
  1111.             }
  1112.             else {
  1113.                 gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), high_value);
  1114.             }
  1115.             return;
  1116.         }
  1117.         else if((attribute==ATTR_T_LENGTH) && (l = length_of(type_name)) >= 0) {
  1118.             gen_kv(I_PUSH_IMMEDIATE, kind_of(type_name), int_const(l));
  1119.             return;
  1120.  
  1121.             /* and in case none of the above worked */
  1122.         }
  1123.         else {
  1124.             gen_type_attr(type_name, attribute);
  1125.         }
  1126.         break;
  1127.  
  1128.     case(ATTR_O_FIRST):
  1129.         gen_value(arg1);
  1130.         gen_kv(I_ATTRIBUTE, ATTR_O_FIRST, get_ivalue(arg2));
  1131.         break;
  1132.  
  1133.     case(ATTR_FIRST_BIT):
  1134.     case(ATTR_LAST_BIT):
  1135.     case(ATTR_POSITION):
  1136.  
  1137.         comp_node = N_AST2(arg1);
  1138.         type_name = TYPE_OF(N_UNQ(N_AST1(arg1)));
  1139.         comp_name = N_UNQ(comp_node);
  1140.         repr_tup= REPR(type_name);
  1141.         align_info = (Tuple) repr_tup[4];       /* alignment_info*/
  1142.         attribute_list = (Tuple) align_info[2];
  1143.         FORTUP(tup=(Tuple),attribute_list,ft1);
  1144.           field = (Symbol) tup[1];
  1145.           if (comp_name == field) {
  1146.              if (attribute == ATTR_POSITION) {
  1147.                    ivalue_int  = (int) tup[2]; /* position */
  1148.              }
  1149.              else if (attribute == ATTR_FIRST_BIT) {
  1150.                    ivalue_int  = (int) tup[3]; /* first_bit */
  1151.              }
  1152.              else {
  1153.                    ivalue_int  = (int) tup[4]; /* last_bit */
  1154.              }
  1155.                gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer),
  1156.                     int_const(ivalue_int));
  1157.              return;
  1158.           }    
  1159.         ENDFORTUP(ft1);
  1160.         break;
  1161.  
  1162.     case(ATTR_FORE):
  1163.         type_name = N_UNQ(arg1);
  1164.         if (is_static_type(type_name)) {
  1165.             tup = get_constraint(type_name);
  1166.             lbd_node = (Node) tup[2];
  1167.             ubd_node = (Node) tup[3];
  1168.             old_lbd = get_ivalue(lbd_node);
  1169.             old_ubd = get_ivalue(ubd_node);
  1170.             if (rat_gtr(rat_abs(RATV(old_lbd)), rat_abs(RATV(old_ubd))) ) {
  1171.                 rat_t = rat_abs(RATV(old_lbd));
  1172.                 rat_n = num(rat_t); 
  1173.                 rat_d = den(rat_t);
  1174.                 /*[n, d] = rat_abs(old_lbd);*/
  1175.             }
  1176.             else {
  1177.                 /*[n, d] = rat_abs(old_ubd);*/
  1178.                 rat_t = rat_abs(RATV(old_ubd));
  1179.                 rat_n = num(rat_t); 
  1180.                 rat_d = den(rat_t);
  1181.             }
  1182.             ivalue_n = 2;
  1183.             while (int_geq(int_quo(rat_n , rat_d) , ivalue_10)) {
  1184.                 rat_d = int_mul(rat_d, ivalue_10);
  1185.                 ivalue_n += 1;
  1186.             }
  1187.             gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer),
  1188.               int_const(ivalue_n));
  1189.         }
  1190.         else {
  1191.             rat_const_v = small_of(base_type(type_name)); 
  1192.             rat = RATV(rat_const_v);
  1193.             rat_n = num(rat); 
  1194.             rat_d = den(rat);
  1195.             gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(int_toi(rat_n)));
  1196.             gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(int_toi(rat_d)));
  1197.             gen_type_attr(type_name, ATTR_FORE);
  1198.         }
  1199.         break;
  1200.  
  1201.     case(ATTR_IMAGE):
  1202.         type_name = N_UNQ(arg1);
  1203.         gen_value(arg2);
  1204.         gen_type_attr(type_name, ATTR_IMAGE);
  1205.         break;
  1206.  
  1207.     case(ATTR_LARGE):
  1208.         type_name = N_UNQ(arg1);
  1209.         to_type   = N_TYPE(node);
  1210.         if (is_fixed_type(type_name)) {
  1211.             Rational rt, rb;
  1212.             int* small_ratio;
  1213.             int* scaled_large;
  1214.  
  1215.             rt = RATV(small_of(type_name));
  1216.             rb = RATV(small_of(base_type(type_name)));
  1217.             rvalue = rat_div(rt, rb);
  1218.             small_ratio = int_quo(num(rvalue), den(rvalue));
  1219.  
  1220.             if (is_static_type(type_name)) {
  1221.                 tup = get_constraint(type_name);
  1222.                 lbd_node = (Node) tup[2];
  1223.                 ubd_node = (Node) tup[3];
  1224.                 old_lbd = get_ivalue(lbd_node);
  1225.                 old_ubd = get_ivalue(ubd_node);
  1226.  
  1227.                 /* large = (2 ** mantissa -1) * small  
  1228.                  * The run-time representation is in units of the base small,
  1229.                  * but of course the mantissa is that of the type, not the base.
  1230.                  * We scale the result by the ratios of the two smalls.
  1231.                  */
  1232.                 scaled_large  = int_mul(int_sub(int_exp(int_fri(2),
  1233.                   int_fri(fx_mantissa(RATV(old_lbd), RATV(old_ubd), rt))),
  1234.                   int_fri(1)), small_ratio);
  1235.  
  1236.                 if (is_fixed_type(to_type)) {
  1237.                     /* emit as fixed point number, i.e. long value */
  1238.                     gen_kv(I_PUSH_IMMEDIATE, kind_of(to_type),
  1239.                       fixed_const(int_tol(scaled_large)));
  1240.                 }
  1241.                 else {   /* convert to floating type */
  1242.                     Rational rat_val;
  1243.                     rat_val = rat_new(int_mul(scaled_large, num(rb)), den(rb));
  1244.                     fvalue = rat_tor(rat_val, ADA_REAL_DIGITS);
  1245.                     gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_float),
  1246.                       real_const(fvalue));
  1247.                 }
  1248.             }
  1249.             else {
  1250.                 /* Compute ratio between subtype's SMALL and base type's */
  1251.                 /* SMALL and push it (always integer) */
  1252.                 gen_kv(I_PUSH_IMMEDIATE, mu_word,
  1253.                   int_const(int_toi(small_ratio)));
  1254.                 gen_type_attr(type_name, ATTR_LARGE);
  1255.                 if(base_type(type_name) != base_type(to_type))
  1256.                     gen_convert(type_name, to_type);
  1257.             }
  1258.         }
  1259.         else { /*floating points: folded by FE unless it appears in a generic */
  1260.             tup = SIGNATURE(type_name);
  1261.             digs = (Node) tup[4];
  1262.             digits_int   = get_ivalue_int(digs);
  1263.             fmantissa    = float_mantissa(digits_int);
  1264.             fvalue       = (1.0-(pow(2.0, -(double) fmantissa)))
  1265.               * pow(2.0, (4.0 * fmantissa));
  1266.             gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_float), real_const(fvalue));
  1267.         }
  1268.         break;
  1269.         /*  ("T_LAST"):  $ cf 'T_FIRST' */
  1270.  
  1271.     case(ATTR_O_LAST):
  1272.         gen_value(arg1);
  1273.         gen_kv(I_ATTRIBUTE, ATTR_O_LAST, get_ivalue(arg2));
  1274.         break;
  1275.  
  1276.  
  1277.         /*  ("T_LENGTH"): $ cf 'T_FIRST' */
  1278.  
  1279.     case(ATTR_O_LENGTH):
  1280.         gen_value(arg1);
  1281.         gen_kv(I_ATTRIBUTE, ATTR_O_LENGTH, get_ivalue(arg2));
  1282.         break;
  1283.  
  1284.     case(ATTR_MACHINE_EMAX):
  1285.         gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer), int_const(127));
  1286.         break;
  1287.  
  1288.     case(ATTR_MACHINE_EMIN):
  1289.         gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer), int_const(-128));
  1290.         break;
  1291.  
  1292.     case(ATTR_MACHINE_MANTISSA):
  1293.         gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer), int_const(24));
  1294.         break;
  1295.  
  1296.     case(ATTR_MACHINE_OVERFLOWS):
  1297.         gen_kv(I_PUSH_IMMEDIATE, mu_byte, int_const(TRUE));
  1298.         break;
  1299.  
  1300.     case(ATTR_MACHINE_RADIX):
  1301.         gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer), int_const(2));
  1302.         break;
  1303.  
  1304.     case(ATTR_MACHINE_ROUNDS):
  1305.         gen_kv(I_PUSH_IMMEDIATE, mu_byte, int_const(TRUE));
  1306.         break;
  1307.  
  1308.     case(ATTR_MANTISSA):
  1309.         type_name = N_UNQ(arg1);
  1310.         if (is_fixed_type(type_name)) {
  1311.             if (is_static_type(type_name) ) {
  1312.                 tup = get_constraint(type_name);
  1313.                 lbd_node = (Node) tup[2];
  1314.                 ubd_node = (Node) tup[3];
  1315.                 old_lbd = get_ivalue(lbd_node);
  1316.                 old_ubd = get_ivalue(ubd_node);
  1317.                 ivalue_int  = fx_mantissa(RATV(old_lbd), RATV(old_ubd),
  1318.                   RATV(small_of(type_name)));
  1319.                 gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(ivalue_int));
  1320.             }
  1321.             else {
  1322.                 /* Compute ratio between subtype's SMALL and base type's */
  1323.                 /* SMALL and push it (always integer) */
  1324.                 const_1 = small_of(type_name);
  1325.                 const_2 = small_of(base_type(type_name));
  1326.                 rvalue = rat_div(RATV(const_1), RATV(const_2));
  1327.                 gen_kv(I_PUSH_IMMEDIATE, mu_word,
  1328.                   int_const(int_toi(int_quo(num(rvalue) , den(rvalue)))));
  1329.                 gen_type_attr(type_name, ATTR_MANTISSA);
  1330.             }
  1331.         }
  1332.         else { /*floating points: folded by FE unless it appears in a generic */
  1333.             tup = SIGNATURE(type_name);
  1334.             digs = (Node) tup[4];
  1335.             digits_int       = get_ivalue_int(digs);
  1336.             ivalue_int       = float_mantissa(digits_int);
  1337.             gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer),
  1338.               int_const(ivalue_int));
  1339.         }
  1340.         break;
  1341.  
  1342.         /*  ("POS"):      $ Transformed by expander */
  1343.  
  1344.     case(ATTR_PRED):
  1345.         type_name = N_UNQ(arg1);
  1346.         gen_value(arg2);
  1347.         gen_type_attr(type_name, ATTR_PRED);
  1348.         break;
  1349.  
  1350.         /*  ("T_RANGE"):  $ cf 'T_FIRST' */
  1351.  
  1352.     case(ATTR_O_RANGE):
  1353.         gen_value(arg1);
  1354.         gen_kv(I_ATTRIBUTE, ATTR_O_RANGE, get_ivalue(arg2));
  1355.         break;
  1356.  
  1357.     case(ATTR_SAFE_EMAX):
  1358.         gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer), int_const(127));
  1359.         break;
  1360.  
  1361.     case(ATTR_SAFE_LARGE):
  1362.         /* chaos("expr.c - untranslated code reached"); */
  1363.         gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_float),
  1364.           real_const(ADA_MAX_REAL));
  1365.         break;
  1366.  
  1367.     case(ATTR_SAFE_SMALL):
  1368.         gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_float),
  1369.           real_const(pow(2.0, -129.0)));
  1370.         break;
  1371.  
  1372.     case(ATTR_T_SIZE):
  1373.         type_name = N_UNQ(arg1);
  1374.         if (has_static_size(type_name)) {
  1375.              repr_tup = REPR(type_name);
  1376.              if (repr_tup != (Tuple)0) {
  1377.                 ivalue_int = (int) repr_tup[2];       /* size */
  1378.                 gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer),
  1379.                          int_const(ivalue_int));
  1380.              }
  1381.              else { /* size representation not counted due to some error */
  1382.                 gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_integer),
  1383.                          int_const(BITS_SU * size_of(type_name)));
  1384.              }
  1385.         }
  1386.         else {
  1387.             gen_type_attr(type_name, ATTR_SIZE);
  1388.         }
  1389.         break;
  1390.  
  1391.     case(ATTR_O_SIZE):
  1392.  
  1393.         /* The evaluation of this attribute has to evaluate the object
  1394.          * because this evaluation may raise an exception, for example.
  1395.          * Therefore we have a junk variable that is just used for this
  1396.          * purpose. Since there is no O_SIZE attribute in the Ada machine, the
  1397.          * size of the object is still calculated from T_SIZE
  1398.          */
  1399.  
  1400.         type_name = get_type(N_AST2(node));
  1401.         if (is_simple_name (N_AST2 (node)) && !is_unconstrained (type_name)) {
  1402.             /* this is the simplest case */
  1403.             gen_type_attr(type_name, ATTR_SIZE);
  1404.         }
  1405.         else if ((!is_unconstrained(type_name)) && (!is_array_type(type_name))){
  1406.             /* the object has to be evaluated */
  1407.             junk_var = new_unique_name("junk");  /*TBSL:Reusing same variable */
  1408.             next_local_reference(junk_var);
  1409.             gen_ks(I_DECLARE, kind_of(type_name), junk_var);
  1410.             gen_value(N_AST2(node));
  1411.             gen_ksc(I_POP, kind_of(type_name), junk_var,
  1412.               "Used only for eval. attr. size");
  1413.             gen_type_attr(type_name, ATTR_SIZE);
  1414.         }
  1415.         else {
  1416.             gen_value(N_AST2(node));
  1417.             gen_kv(I_ATTRIBUTE, ATTR_SIZE, int_const(0));
  1418.             if (is_array_type (type_name)) {
  1419.                  /* TBSL: Reusing same variable */
  1420.                 junk_var    = new_unique_name("junk");
  1421.                 next_local_reference(junk_var);
  1422.                 gen_ks(I_DECLARE, kind_of(symbol_integer), junk_var);
  1423.                 gen_ksc(I_POP, kind_of(symbol_integer), junk_var,
  1424.                   "Used only for eval. attr. size");
  1425.                 gen_ks (I_DISCARD_ADDR, 1, (Symbol) 0);
  1426.                 gen_ks(I_PUSH, kind_of(symbol_integer), junk_var);
  1427.             }
  1428.         }
  1429.         break;
  1430.  
  1431.     case(ATTR_SMALL):
  1432.         type_name = N_UNQ(arg1);
  1433.         to_type   = N_TYPE(node);
  1434.         if (is_fixed_type(type_name)) {
  1435.             type_small = small_of(type_name);
  1436.             root_small = small_of(base_type(type_name));
  1437.             if (is_fixed_type(to_type)) {
  1438.                 rvalue_long = rat_tof(type_small, small_of(base_type(to_type)),
  1439.                   size_of(to_type));
  1440.                 gen_kv(I_PUSH_IMMEDIATE, kind_of(to_type),
  1441.                   fixed_const(rvalue_long));
  1442.             }
  1443.             else {   /* convert to floating type */
  1444.                 fvalue = rat_tor(RATV(type_small), ADA_REAL_DIGITS);
  1445.                 gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_float),
  1446.                   real_const(fvalue));
  1447.             }
  1448.         }
  1449.         else { /*floating points: folded by FE unless it appears in a generic */
  1450.             tup = SIGNATURE(type_name);
  1451.             digs = (Node) tup[4];
  1452.             digits_int   = get_ivalue_int(digs);
  1453.             fmantissa    = float_mantissa(digits_int);
  1454.             fvalue       = pow(2.0, (-4.0*fmantissa-1.0));
  1455.             gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_float), real_const(fvalue));
  1456.         }
  1457.         break;
  1458.  
  1459.     case(ATTR_STORAGE_SIZE):
  1460.         if (N_KIND(arg1) == as_all) { /* form of Obj.all'STORAGE_SIZE */
  1461.             type_name = get_type(N_AST1(arg1));
  1462.         }
  1463.         else {
  1464.             type_name = N_UNQ(arg1);
  1465.         }
  1466.         /*
  1467.          * Since the collection size information is kept in the access
  1468.          * template only , we must generate a reference to the base type 
  1469.          * in the case of STORAGE_SIZE on a subtype.
  1470.          */    
  1471.         if (NATURE(type_name) == na_subtype) {
  1472.             type_name = base_type(type_name);
  1473.         }
  1474.         gen_type_attr(type_name, ATTR_STORAGE_SIZE);
  1475.         break;
  1476.  
  1477.     case(ATTR_SUCC):
  1478.         type_name = N_UNQ(arg1);
  1479.         gen_value(arg2);
  1480.         gen_type_attr(type_name, ATTR_SUCC);
  1481.         break;
  1482.  
  1483.     case(ATTR_TERMINATED):
  1484.         gen_value(arg1);
  1485.         gen_kv(I_ATTRIBUTE, ATTR_TERMINATED, int_const(0));
  1486.         break;
  1487.  
  1488.     case(ATTR_VAL):
  1489.         from_type = base_type(get_type(arg2));
  1490.         to_type   = N_TYPE(node);
  1491.         gen_value(arg2);
  1492.         gen_convert(from_type, to_type);
  1493.         gen_s(I_QUAL_RANGE, to_type);
  1494.         break;
  1495.  
  1496.     case(ATTR_VALUE):
  1497.         type_name = N_UNQ(arg1);
  1498.         gen_value(arg2);
  1499.         gen_type_attr(type_name, ATTR_VALUE);
  1500.         break;
  1501.  
  1502.     case(ATTR_WIDTH):
  1503.         type_name = N_UNQ(arg1);
  1504.         if (is_static_type(type_name)) {
  1505.             tup = SIGNATURE(type_name);
  1506.             low = (Node) tup[2];
  1507.             high = (Node) tup[3];
  1508.             low_value = get_ivalue (low);
  1509.             high_value = get_ivalue (high);
  1510.  
  1511.             /* this following test has been added because the bounds of the
  1512.              * range may be not static. In the previous version there was an
  1513.              * error during the get_ivalue_int
  1514.              */
  1515.  
  1516.             if (low_value->const_kind == CONST_OM
  1517.               || high_value->const_kind == CONST_OM)  {
  1518.                 gen_type_attr(type_name, ATTR_WIDTH); 
  1519.             }
  1520.             else {
  1521.                 low_int  = get_ivalue_int(low);
  1522.                 high_int = get_ivalue_int(high);
  1523.                 if (is_integer_type(type_name)) {
  1524.                     if (low_int > high_int)
  1525.                         gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(0));
  1526.                     else {
  1527.                         char *val_str = emalloct(10, "gen-attr-wid-1");
  1528.                         low_int =  abs (low_int);
  1529.                         high_int = abs (high_int);
  1530.                         ivalue_int = (low_int > high_int ? low_int : high_int);
  1531.                         sprintf(val_str, " %d", ivalue_int);
  1532.                         ivalue_int = strlen(val_str);
  1533.                         efreet(val_str, "gen-attr-wid-2");
  1534.                         gen_kv(I_PUSH_IMMEDIATE, mu_word,int_const(ivalue_int));
  1535.                     }
  1536.                 }
  1537.                 /* following code does not work for bool and char.
  1538.                  * disable for now.
  1539.                  */
  1540.                 else {     /* Enumeration types */
  1541.                     int len, v;
  1542.                     tup = (Tuple) literal_map(root_type(type_name));
  1543.                     ivalue_int = 0;
  1544.                     for (i = 1; i <= tup_size(tup); i += 2) {
  1545.                         len = strlen(tup[i]);
  1546.                         v = (int) tup[i+1];
  1547.                         if (len > ivalue_int && (v >= low_int && v <= high_int))
  1548.                           ivalue_int = len;
  1549.                     }
  1550.                     gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(ivalue_int));
  1551.                 }
  1552.             } 
  1553.         }
  1554.         else { /* Not static types */
  1555.             gen_type_attr(type_name, ATTR_WIDTH);
  1556.         }
  1557.         break;
  1558.  
  1559.     default:
  1560.         compiler_error("Unexpected attribute ");
  1561.     }
  1562. }
  1563.  
  1564. static int float_mantissa(int digits)                    /*;float_mantissa*/
  1565. {
  1566.     return (digits < 4 ? (3 * digits + 2) : (3 * digits + 3) );
  1567. }
  1568.  
  1569. static void gen_type_attr(Symbol type_name, int a_attribute) /*;gen_type_attr*/
  1570. {
  1571.     gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  1572.     gen_kv(I_ATTRIBUTE, a_attribute, int_const(0));
  1573. }
  1574.  
  1575. void gen_convert(Symbol from_type, Symbol to_type)            /*;gen_convert*/
  1576. {
  1577.     if (is_fixed_type(from_type) && is_integer_type(to_type)) {
  1578.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, from_type);
  1579.         gen_s(I_CONVERT_TO, symbol_dfixed);
  1580.         from_type = symbol_dfixed;
  1581.     }
  1582.     else if (is_integer_type(from_type) && is_fixed_type(to_type)) {
  1583.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, from_type);
  1584.         gen_s(I_CONVERT_TO, symbol_dfixed);
  1585.         from_type = symbol_dfixed;
  1586.     }
  1587.     if (!is_array_type(from_type)) {
  1588.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, from_type);
  1589.     }
  1590.     if (is_array_type(to_type) && is_unconstrained(to_type)) {
  1591.         gen_s(I_QUAL_SUB, to_type);
  1592.     }
  1593.     else {
  1594.         gen_s(I_CONVERT_TO, to_type);
  1595.     }
  1596. }
  1597.  
  1598. void gen_access_qual(int qualifier, Symbol type_name)        /*;gen_access_qual*/
  1599. {
  1600.     Symbol    null_access;
  1601.  
  1602.     gen_k(I_DUPLICATE, mu_addr);
  1603.     gen_s(I_PUSH_EFFECTIVE_ADDRESS, symbol_null);
  1604.     gen_k(I_COMPARE, mu_addr);
  1605.     null_access = new_unique_name("null_access");
  1606.     gen_s(I_JUMP_IF_TRUE, null_access);
  1607.     if (qualifier == as_qual_index) {
  1608.         gen_k(I_DUPLICATE, mu_addr);
  1609.         gen_k(I_DEREF, mu_dble);
  1610.         gen_s(I_QUAL_INDEX, type_name);
  1611.         gen_ks(I_DISCARD_ADDR, 2, (Symbol)0);
  1612.     }
  1613.     else if (qualifier == as_qual_discr) {
  1614.         /* Note: an access to a record type does not require
  1615.          * any derefencing!
  1616.          */
  1617.         gen_s(I_QUAL_DISCR, type_name);
  1618.     }
  1619.     else
  1620.         compiler_error("Illegal access qual");
  1621.     gen_s(I_LABEL, null_access);
  1622. }
  1623.  
  1624. Segment array_ivalue(Node node)                            /*;array_ivalue*/
  1625. {
  1626.     /* Returns the ivalue part of an array object, i.e. a segment having the
  1627.      * size of the object, with all static components initialized
  1628.      * In C, the returned value is a Segment.
  1629.      */
  1630.  
  1631.     Node   static_node, selector_node, val_node, static_comp_node,
  1632.       access_node, list_node;
  1633.     Symbol    obj_type, comp_type, selector_name;
  1634.     Tuple    tup, subscript_list;  /* tuple(integer); */
  1635.     int        offset, i, index, comp_size, str_len, nk, n;
  1636.     Segment    res, obj_value;
  1637.     Tuple    tupstr, index_list;
  1638.     Const    exprv;
  1639.     Fortup    ft1;
  1640.  
  1641. #ifdef TRACE
  1642.     if (debug_flag)
  1643.         gen_trace_node("ARRAY_IVALUE", node);
  1644. #endif
  1645.  
  1646.     nk = N_KIND(node);
  1647.     if (nk == as_string_ivalue) {
  1648.         /*  CASE 1.  String
  1649.          *    Create a segment and copy the characters from the string tuple   
  1650.          *    to the data segment
  1651.          */
  1652.         tupstr = (Tuple) N_VAL(node);
  1653.         n = tup_size(tupstr);
  1654.         res = segment_new(SEGMENT_KIND_DATA, n);
  1655.         for (i = 1; i <= n; i++)
  1656.             segment_put_word(res, (int) tupstr[i]);
  1657.         return res;
  1658.     }
  1659.     else if (nk == as_array_aggregate || nk == as_array_ivalue) {
  1660.         /* CASE 2:  arr_aggreagate -or- array_ivalue
  1661.          *  Note: obj_type may be unconstrained in the case where the array 
  1662.          *  subtype is identical to the base type. (not "really" unconstrained).
  1663.          */
  1664.         static_node = N_AST1(N_AST1(node)); 
  1665.         obj_type = N_TYPE(node);
  1666.         if (!has_static_size(obj_type)) {
  1667.             compiler_error("Ivalue of not static size array aggr.");
  1668.             return segment_new(SEGMENT_KIND_DATA, 0);
  1669.         }
  1670.         /* Step 1:  Create a segment and initialize it */
  1671.         obj_value = segment_new(SEGMENT_KIND_DATA, size_of(obj_type));
  1672.         for (i = 0; i < size_of(obj_type); i++)
  1673.             segment_put_word(obj_value, 0);
  1674.         /* Step 2:  Calculate the offset for each static component */
  1675.         FORTUP(static_comp_node = (Node), N_LIST(static_node), ft1);
  1676.             offset      = 0;
  1677.             access_node = N_AST1(static_comp_node);
  1678.             val_node    = N_AST2(static_comp_node);
  1679.             while (!is_simple_name(access_node)) {
  1680.                 if (N_KIND(access_node) == as_index){
  1681.                     list_node   = N_AST2(access_node);
  1682.                     access_node = N_AST1(access_node);
  1683.                     obj_type    = get_type(access_node);
  1684.                     tup         = SIGNATURE(obj_type);
  1685.                     index_list  = (Tuple) tup[1];
  1686.                     comp_type   = (Symbol) tup[2];
  1687.                     comp_size   = size_of(comp_type);
  1688.                     subscript_list = N_LIST(list_node);
  1689.                     index       = compute_index(subscript_list, index_list);
  1690.                     offset      += index*comp_size;
  1691.                 }
  1692.                 else if (N_KIND(access_node) == as_selector) {
  1693.                     selector_node = N_AST2(access_node);
  1694.                     access_node   = N_AST1(access_node);
  1695.                     obj_type      = get_type(access_node);
  1696.                     selector_name = N_UNQ (selector_node);
  1697.                     comp_type     = TYPE_OF(selector_name);
  1698.                     offset       += FIELD_OFFSET(selector_name);
  1699.                 }
  1700.                 else {
  1701.                     compiler_error("Incoherent access list in array agg.");
  1702.                     break;
  1703.                 }
  1704.             }
  1705.  
  1706.             /* Step 3:  Copy the component value into the correct position
  1707.              * in the segment
  1708.              */
  1709.             if (N_KIND(val_node) == as_string_ivalue) {
  1710.                 segment_set_pos(obj_value, (unsigned) offset, 0);
  1711.                 tup = (Tuple) N_VAL(val_node);
  1712.                 str_len = tup_size(tup);
  1713.                 for (i = 1; i <= str_len; i++)
  1714.                     segment_put_word(obj_value, (int) tup[i]);
  1715.             }
  1716.             else if (N_KIND(val_node) == as_ivalue
  1717.               || N_KIND(val_node) == as_int_literal
  1718.               || N_KIND(val_node) == as_real_literal) {
  1719.                 exprv = get_ivalue(val_node);
  1720.                 comp_type = N_TYPE(val_node);
  1721.                 if (is_fixed_type(comp_type)) {
  1722.                     /* we have to take into account if the node val is fixed */
  1723.                     exprv = fixed_const(rat_tof( exprv,
  1724.                          small_of(base_type(comp_type)), size_of(comp_type)));
  1725.                 }
  1726.                 if (is_const_uint(exprv)) {
  1727.                       /* try to convert universal integer to integer */
  1728.                        i= int_toi(UINTV(exprv));
  1729.                      if (arith_overflow) {/* if cannot convert to integer */
  1730.                             chaos("cannot convert uint to int in array_ivalue");
  1731.                      }
  1732.                     exprv = int_const(i);
  1733.                    }
  1734.                 segment_set_pos(obj_value, offset, 0);
  1735.                 segment_put_const(obj_value, exprv);
  1736.  
  1737.                 /* segment_set_pos(obj_value, (unsigned) offset, 0);
  1738.                  * segment_put_const(obj_value, get_ivalue(val_node));
  1739.                  */
  1740.             }
  1741.             else {
  1742.                 compiler_error("Static comp in array aggregate not ivalue");
  1743.             }
  1744.         ENDFORTUP(ft1);
  1745.     }
  1746.     /* there was an error message here */
  1747.     return obj_value;
  1748. }
  1749.  
  1750. Segment record_ivalue(Node node)                        /*;record_ivalue*/
  1751. {
  1752.     /* Returns the ivalue part of a record object, i.e. a tuple having the
  1753.      * size of the object, with all static components initialized
  1754.      * In C, the returned value is a segment.
  1755.      */
  1756.  
  1757.     Node    static_node, selector_node, val_node;
  1758.     Node    static_comp_node, access_node, list_node;
  1759.     Symbol    obj_type, comp_type, selector_name;
  1760.     Segment    obj_value;  /* tuple(integer); */
  1761.     int        i, index, comp_size, nk;
  1762.     Fortup    ft1;
  1763.     Segment    sval;
  1764.     Const       exprv;
  1765.     Tuple    tup, subscript_list, index_list;
  1766.     unsigned    offset;
  1767.     Segment     tempseg;
  1768.  
  1769.     sval = segment_new(SEGMENT_KIND_DATA, 1);
  1770.     nk = N_KIND(node);
  1771.     if (nk == as_record_aggregate || nk == as_record_ivalue) {
  1772.         static_node = N_AST1(N_AST1(node));
  1773.         /*init_node = N_AST2(node); -- init_node not used  ds 7-8-85 */
  1774.         /*name_node = N_AST3(node); -- name_node not used  ds 7-8-85*/
  1775.         obj_type  = N_TYPE(node);
  1776.  
  1777.         if (! has_static_size(obj_type)) {
  1778.             compiler_error("Ivalue of not static size record aggr.");
  1779.             return sval;
  1780.         }
  1781.         /* TBSL: see that obj_value properly intialized  ds 6-26-85*/
  1782.         obj_value = segment_new(SEGMENT_KIND_DATA, size_of(obj_type));
  1783.         /* obj_value = [1..size_of(obj_type)];*/
  1784.  
  1785.         FORTUP(static_comp_node = (Node), N_LIST(static_node), ft1);
  1786.             offset   = 0; /* a segment start at position 0 in c version */
  1787.             access_node = N_AST1(static_comp_node);
  1788.             val_node = N_AST2(static_comp_node);
  1789.             while (! is_simple_name(access_node)) {
  1790.                 nk = N_KIND(access_node);
  1791.                 if (nk == as_index) {
  1792.                     list_node= N_AST2(access_node);
  1793.                     access_node = N_AST1(access_node);
  1794.                     obj_type    = get_type(access_node);
  1795.                     tup = SIGNATURE(obj_type);
  1796.                     index_list = (Tuple) tup[1];
  1797.                     comp_type = (Symbol) tup[2];
  1798.                     comp_size = size_of(comp_type);
  1799.                     subscript_list = N_LIST(list_node);
  1800.                     index = compute_index(subscript_list, index_list);
  1801.                     offset += index*comp_size;
  1802.                 }
  1803.                 else if (nk == as_selector) {
  1804.                     selector_node = N_AST2(access_node);
  1805.                     access_node = N_AST1(access_node);
  1806.                     obj_type = get_type(access_node);
  1807.                     selector_name = N_UNQ(selector_node);
  1808.                     comp_type = TYPE_OF(selector_name);
  1809.                     offset += FIELD_OFFSET(selector_name);
  1810.                 }
  1811.                 else {
  1812.                     compiler_error("Incoherent access list in record agg.");
  1813.                     break;
  1814.                 }
  1815.             }
  1816.  
  1817.             /* We have now reached a simple type ivalue */
  1818.             nk = N_KIND(val_node);
  1819.             if (nk == as_string_ivalue) {
  1820.                 tup = (Tuple) N_VAL(val_node);
  1821.                 segment_set_pos(obj_value, offset, 0);
  1822.                 for (i = 1; i<= tup_size(tup); i++)
  1823.                     segment_put_int(obj_value, (int) tup[i]);
  1824.             }
  1825.             else if (nk == as_array_ivalue) {
  1826.                 tempseg = array_ivalue(val_node);
  1827.                 segment_set_pos(obj_value, offset, 0);
  1828.                 for (i = 0; i < segment_get_maxpos(tempseg); i ++) {
  1829.                     segment_put_int(obj_value,
  1830.                       (int) segment_get_int(tempseg, i));
  1831.                 }
  1832.             }
  1833.             else if (nk == as_ivalue || nk == as_int_literal
  1834.               || nk == as_real_literal) {
  1835.                 exprv = get_ivalue(val_node);
  1836.                 comp_type = N_TYPE(val_node);
  1837.                 if (is_fixed_type(comp_type)) {
  1838.                     exprv = fixed_const(rat_tof( exprv,
  1839.                       small_of(base_type(comp_type)), size_of(comp_type)));
  1840.                 }
  1841.                 segment_set_pos(obj_value, offset, 0);
  1842.                 segment_put_const(obj_value, exprv);
  1843.             }
  1844.             else
  1845.                 compiler_error("Static component in aggregate not ivalue");
  1846.         ENDFORTUP(ft1);
  1847.     }
  1848.     else {
  1849.         compiler_error_k("Not implemented : ", val_node);
  1850.         compiler_error("record_ivalue - unknown node kind");
  1851.     }
  1852.     /*
  1853.      * Initialize the rest of the segment with zeros. Note that this value
  1854.      * has to be the same in intb.c - create_struc.
  1855.      * This affects only unconstrained records.
  1856.      */
  1857.     segment_set_pos(obj_value, (unsigned) segment_get_maxpos(obj_value), 0);
  1858.     for (i = segment_get_pos(obj_value); i < size_of(obj_type); i++) {
  1859.         segment_put_int(obj_value, 0);
  1860.     }
  1861.     return obj_value;
  1862. }
  1863.  
  1864. static int code_map(Symbol opcode)        /*;code_map*/
  1865. {
  1866.     code_map_defined = TRUE; /* assume can map to machine instruction */
  1867.     if (opcode == symbol_and) return        I_AND;
  1868.     else if (opcode == symbol_or) return         I_OR;
  1869.     else if (opcode == symbol_xor) return        I_XOR;
  1870.  
  1871.     else if (opcode == symbol_eq) return          I_IS_EQUAL;
  1872.     else if (opcode == symbol_ne) return         I_NOT;
  1873.     else if (opcode == symbol_le) return         I_IS_LESS_OR_EQUAL;
  1874.     else if (opcode == symbol_gt) return          I_IS_GREATER;
  1875.     else if (opcode == symbol_ge) return         I_IS_GREATER_OR_EQUAL;
  1876.     else if (opcode == symbol_lt) return          I_IS_LESS;
  1877.  
  1878.     else if (opcode == symbol_addi) return         I_ADD;
  1879.     else if (opcode == symbol_subi) return         I_SUB;
  1880.     else if (opcode == symbol_addfx) return        I_ADD;
  1881.     else if (opcode == symbol_subfx) return        I_SUB;
  1882.  
  1883.     else if (opcode == symbol_muli) return         I_MUL;
  1884.     else if (opcode == symbol_divi) return         I_DIV;
  1885.     else if (opcode == symbol_remi) return       I_REM;
  1886.     else if (opcode == symbol_modi) return       I_MOD;
  1887.     else if (opcode == symbol_expi) return        I_POW;
  1888.  
  1889.     else if (opcode == symbol_addfl) return        I_FLOAT_ADD;
  1890.     else if (opcode == symbol_subfl) return        I_FLOAT_SUB;
  1891.     else if (opcode == symbol_mulfl) return        I_FLOAT_MUL;
  1892.     else if (opcode == symbol_divfl) return        I_FLOAT_DIV;
  1893.     else if (opcode == symbol_expfl) return       I_FLOAT_POW;
  1894.  
  1895.     else if (opcode == symbol_mulfix) return       I_FIX_MUL;
  1896.     else if (opcode == symbol_mulfxi) return       I_FIX_MUL;
  1897.     else if (opcode == symbol_mulfx) return        I_FIX_MUL;
  1898.     else if (opcode == symbol_divfxi) return       I_FIX_DIV;
  1899.     else if (opcode == symbol_divfx) return        I_FIX_DIV;
  1900.     else {
  1901.         code_map_defined = FALSE;
  1902.         return 0;
  1903.     }
  1904. }
  1905.